home *** CD-ROM | disk | FTP | other *** search
/ System Booster / System Booster.iso / Desktop Improver / IconTools / source / IconTools.f < prev    next >
Encoding:
FORTH Source  |  1996-09-27  |  8.9 KB  |  440 lines
  1. \ $VER: IconTools.f 1.00 (19 Jan 1992 23:05)
  2. \ Includes all the stuff common to the IconTools
  3. \ Written in JForth Professional 2.0
  4. \
  5. \ (c) Copyright 1989, 1990, 1992 by Richard Mazzarisi.
  6. \  All rights reserved.
  7. \
  8. \ address:
  9. \    891 Post St. #207
  10. \    San Francisco, CA
  11. \    94109
  12. \
  13. \ email:
  14. \    rich@californium.cchem.berkeley.edu
  15. \    rmazz@hydrogen.cchem.berkeley.edu
  16. \
  17. \
  18. \ v. 1.00 1/7/92
  19. \      1/13/92  moved the resource management routines to this file
  20. \ v. 1.01 1/19/92  noticed that the icon routines in ju:icon-support which
  21. \            are called by ju:set-icon open icon.library but
  22. \            never close it - so do both here explicitly
  23. \
  24.  
  25.  
  26. \ *** includes ***
  27. INCLUDE? CLONE CL:TOPFILE
  28. INCLUDE? LIBRARIES_DOS_H JI:LIBRARIES/DOS.J
  29. INCLUDE? LIBRARIES_DOSEXTENS_H JI:LIBRARIES/DOSEXTENS.J
  30. INCLUDE? GRAPHICS_GFXBASE_H JI:GRAPHICS/GFXBASE.J
  31. INCLUDE? EXEC_MEMORY_H JI:EXEC/MEMORY.J
  32. INCLUDE? TASK-AMIGA_GRAPH JU:AMIGA_GRAPH
  33. INCLUDE? TASK-AMIGA_EVENTS JU:AMIGA_EVENTS
  34. INCLUDE? TASK-CONSOLESUPPORT JU:CONSOLESUPPORT
  35. INCLUDE? TASK-ANSISUPPORT JU:ANSISUPPORT
  36. INCLUDE? TASK-DOS-SUPPORT JU:DOS-SUPPORT
  37. INCLUDE? TASK-SET-ICON JU:SET-ICON
  38. INCLUDE? TASK-LOCALS JU:LOCALS
  39. INCLUDE? TASK-AUTO_REQUEST JU:AUTO_REQUEST
  40.  
  41.  
  42. \ *** clone controller ***
  43.  
  44. .NEED clone-it
  45. VARIABLE clone-it
  46. clone-it OFF
  47. .THEN
  48.  
  49.  
  50. ANEW task-icontools
  51.  
  52.  
  53. \ *** deferred words to be defined in the actual program files
  54.  
  55. DEFER open.it-window
  56. DEFER prt.it-instr
  57.  
  58. \ *** console stuff ***
  59.  
  60. \ variables to hold the request and reply ports
  61. VARIABLE wreq
  62. VARIABLE rreq
  63. VARIABLE wreply
  64. VARIABLE rreply
  65.  
  66.  
  67. : con.cr    ( -- )
  68.     wreq @ $ 0A ConPutChar()
  69. ;
  70.  
  71.  
  72. : con.write    ( straddr -- )
  73.     wreq @    SWAP COUNT ConWrite()
  74. ;
  75.  
  76.  
  77. : con.write.c3 ( straddr -- )
  78. \ write string in color 3
  79.     1 33 2 CRender3  wreq @  >ANSIDEVICE
  80.     con.write
  81.     0 1 CRender3  wreq @  >ANSIDEVICE
  82. ;
  83.  
  84.  
  85. : con.write.itl ( straddr -- )
  86. \ write string in bold italics
  87.     3 1 2 CRender3    wreq @    >ANSIDEVICE
  88.     con.write
  89.     0 1 CRender3  wreq @  >ANSIDEVICE
  90. ;
  91.  
  92.  
  93. : clear.line    ( -- )
  94. \ clear current line
  95.     0 CDeleteLine wreq @ >ANSIDEVICE
  96. ;
  97.  
  98.  
  99. : cursor.off    ( -- )
  100. \ get rid of cursor
  101.     0 CCursOff wreq @ >ANSIDEVICE
  102. ;
  103.  
  104.  
  105. : prt.close-msg     ( -- )
  106.     con.cr
  107.     " Click CloseBox to exit." con.write
  108. ;
  109.  
  110.  
  111. \ *** main window stuff ***
  112.  
  113. NewWindow it-newwindow
  114.  
  115.  
  116. CREATE scr-buff Sizeof() Screen ALLOT
  117.  
  118.  
  119. : getWBscreendata    ( -- )
  120.     scr-buff Sizeof() Screen WBENCHSCREEN NULL
  121.     CALL>ABS INTUITION_LIB GetScreenData  NULL = IF
  122.         ABORT" Could not get Workbench screen data."
  123.     THEN
  124. ;
  125.  
  126.  
  127. : set.vert-params ( topedge #lines -- topedge' height )
  128. \ calc window height, adjust topedge if necessary
  129.     \ get font height
  130.     GRAPHICS_LIB @ >REL ..@ GB_DEFAULTFONT >REL ..@ tf_YSize
  131.     \ estimate height from #lines, title bar height and lower border
  132.     *  scr-buff ..@ sc_BarHeight +    12 +
  133.     \ check if too high
  134.     2DUP +    scr-buff ..@ sc_Height > IF
  135.         \ try adjusting topedge
  136.         SWAP DROP   \ lose old topedge
  137.         scr-buff ..@ sc_Height OVER -  DUP 0< IF
  138.             \ not going to work; set to 0 & screen height
  139.             2DROP
  140.             0  scr-buff ..@ sc_Height
  141.         ELSE
  142.             SWAP
  143.         THEN
  144.     THEN
  145. ;
  146.  
  147.  
  148. : set.horiz-params ( leftedge #chars -- leftedge' width )
  149. \ calc window width, adjust leftedge if necessary
  150.     \ get font width
  151.     GRAPHICS_LIB @ >REL ..@ GB_DEFAULTFONT >REL ..@ tf_XSize
  152.     \ estimate width from #chars, and borders
  153.     *  24 +
  154.     \ check if too wide
  155.     2DUP +    scr-buff ..@ sc_Width > IF
  156.         \ try adjusting leftedge
  157.         SWAP DROP   \ lose old leftedge
  158.         scr-buff ..@ sc_Width OVER -  DUP 0< IF
  159.             \ not going to work; set to 0 & screen width
  160.             2DROP
  161.             0  scr-buff ..@ sc_Width
  162.         ELSE
  163.             SWAP
  164.         THEN
  165.     THEN
  166. ;
  167.  
  168.  
  169. : wait.close    ( -- )
  170.     BEGIN
  171.         GR-CURWINDOW @ EV.WAIT
  172.         GR-CURWINDOW @ EV.GETCLASS
  173.         CLOSEWINDOW =
  174.     UNTIL
  175. ;
  176.  
  177.  
  178. \ *** resource management ***
  179.  
  180. : close.it-things    ( -- )
  181.     con.cr prt.close-msg
  182.     wait.close
  183.     wreq @ 0= NOT IF
  184.         wreply @ wreq @ rreply @ rreq @ ReleaseConsole()
  185.         wreq OFF
  186.     THEN
  187.     -ICON        \ close icon.library
  188.     GR.CLOSECURW
  189.     GR.TERM     \ close graphics
  190. ;
  191.  
  192.  
  193. : it.abort        ( -- )
  194.     con.cr
  195.     close.it-things
  196.     ABORT
  197. ;
  198.  
  199.  
  200. : open.it-things    ( -- t/f )
  201. \ The error messages are for debugging under the interpreter; they won't
  202. \ be able to be seen under the workbench.
  203.     GR.INIT     \ open graphics
  204.     ICON?        \ open icon.library
  205.     wreq OFF
  206.     GR-CURWINDOW OFF
  207.     \ open window
  208.     open.it-window    NULL = IF
  209.         ABORT" Could not open a window!"
  210.     THEN
  211.     \ make it a console
  212.     GR-CURWINDOW @ GetConsole() NULL = IF
  213.         close.it-things
  214.         ABORT" Could not create a console device!"
  215.     ELSE
  216.         rreq ! rreply !  wreq ! wreply !
  217.         cursor.off
  218.     THEN
  219. ;
  220.  
  221.  
  222. \ *** string stuff ***
  223.  
  224. : init.name        ( dest -- )
  225.     0 SWAP !
  226. ;
  227.  
  228.  
  229. : build.name        ( addr count dest -- )
  230. \ build string in buffer at dest, must init to null with init.name before
  231. \ using this word for the first time in building a new path name
  232.     \ check for a non null in first place
  233.     DUP @ 0= IF
  234.         \ it was just initialized so just copy
  235.         >$
  236.     ELSE
  237.         $APPEND
  238.     THEN
  239. ;
  240.  
  241.  
  242. \ *** modified words from JU:SET-ICON ***
  243. \ these must not call ?ABORT" but must use it.abort to clean up
  244. \ (probably don't need most of the error messages but leave them for
  245. \ debugging from the interpreter)
  246.  
  247.  
  248. : it.icon-open?     ( -- , just checks for 0 )
  249.     theIcon @ 0= IF
  250.         " ERROR: No Icon selected ... use GET-ICON" con.write.itl con.cr
  251.         it.abort
  252.     THEN
  253. ;
  254.  
  255.  
  256. : it.abort-icon     ( -- , just clear it out )
  257.     it.icon-open? theIcon @  FreeDiskObject()
  258.     theIcon OFF  thestrings @ FREEBLOCK
  259. ;
  260.  
  261.  
  262. : $it.get-icon        ( adr-forth-string -- )
  263. \ NOTE: do NOT include the '.info' suffix in the pathname
  264. \ does not work for DRAWER icons under WB (see ju:set-icon)
  265. \ this does however work with JazzBench
  266.     theIcon @ IF
  267.         " ERROR: 'theIcon' currently holds another icon."
  268.         con.write.itl con.cr
  269.         it.abort
  270.     THEN
  271.     COUNT >DOS DOS0   GetDiskObject() -DUP 0= IF
  272.         " ERROR: Can't Get the ICON file!" con.write.itl con.cr
  273.         it.abort
  274.     THEN
  275.     theIcon !  MEMF_PUBLIC 1024 ALLOCBLOCK -DUP 0= IF
  276.         " ERROR: No memory for ICON strings!" con.write.itl con.cr
  277.         it.abort
  278.     ELSE
  279.         thestrings !
  280.     THEN
  281. ;
  282.  
  283.  
  284. : $it.save-icon     ( adr-forth-string -- )
  285.     \ AGAIN...do not append the '.info'
  286.     it.icon-open?  COUNT >DOS DOS0    theIcon @  PutDiskObject() 0= IF
  287.         " ERROR while saving DiskObject!" con.write.itl con.cr
  288.         it.abort
  289.     THEN
  290.     theIcon @  FreeDiskObject()  theIcon OFF  thestrings @ FREEBLOCK
  291. ;
  292.  
  293.  
  294. \ *** modified words from JU:AUTO_REQUEST ***
  295. \ want to change the dimensions and position of the requester
  296.  
  297. : 0it.auto.request    ( 0body 0posi 0nega -- flag )
  298.     AR.INIT
  299.     ACTIVE-WINDOW
  300.     BODYTEXT
  301.     POSITEXT
  302.     NEGATEXT
  303.     0 0 320 60          ( these are changed )
  304.     CALL>ABS INTUITION_LIB AutoRequest
  305. ;
  306.  
  307.  
  308. : $it.auto.request    ( $body $posi $nega -- flag )
  309.     AR-NEGA-CHARS AR.GET.TEXT
  310.     AR-POSI-CHARS AR.GET.TEXT
  311.     AR-BODY-CHARS AR.GET.TEXT
  312.     AR-BODY-CHARS AR-POSI-CHARS AR-NEGA-CHARS
  313.     0it.auto.request
  314. ;
  315.  
  316.  
  317. \ *** support ***
  318.  
  319. : check.WB        ( -- )
  320.     \ check if running under WorkBench?
  321.     WBMESSAGE @ NOT IF
  322.         " Must be run under the WorkBench!" con.write.itl con.cr con.cr
  323.         prt.it-instr  it.abort
  324.     THEN
  325. ;
  326.  
  327.  
  328. : check.num.args    ( nreq -- n t | f )
  329. \ We need at least 'nreq' args to make any sense.
  330. \ Returns the actual number of arguments to act on and true;
  331. \   or false if not enough.
  332.     WBMESSAGE @ >REL ..@ sm_NumArgs  DUP ROT <  IF
  333.         \ not enough args; tell'em how
  334.         " Too few arguments!" con.write.itl con.cr con.cr
  335.         prt.it-instr
  336.         DROP FALSE
  337.     ELSE
  338.         1-  ( 1st arg is the prog itself )
  339.         TRUE
  340.     THEN
  341. ;
  342.  
  343.  
  344. : alloc.fib        ( -- fib-addr )
  345.     \ allocate memory for the File Info Block
  346.     MEMF_CLEAR  SizeOf() FileInfoBlock  ALLOCBLOCK
  347.     DUP NULL = IF
  348.         " ERROR: Could not allocate FileInfoBlock!" con.write.itl
  349.     THEN
  350. ;
  351.  
  352.  
  353. : dealloc.fib        ( fib-addr -- )
  354.     \ deallocate memory for the File Info Block
  355.     DUP IF
  356.         FREEBLOCK
  357.     THEN
  358. ;
  359.  
  360.  
  361. : get.parentdir     { lock | fib pdirflg dirflg ok --> dirflg ok }
  362. \ return in dirflg t if parent is a directory, f if it is disk (root) and t/f
  363. \ obviously dirflg is useless if all is not OK
  364.     TRUE -> ok  TRUE -> dirflg
  365.     alloc.fib  DUP -> fib  IF
  366.         \ go upward recursively
  367.         lock ParentDir()  -DUP IF
  368.             DUP fib Examine()  DROP
  369.             RECURSE  SWAP -> pdirflg  IF
  370.                 fib .. fib_FileName  0COUNT  PAD build.name
  371.                 pdirflg IF
  372.                     " /" COUNT  PAD build.name
  373.                 ELSE
  374.                     " :" COUNT  PAD build.name
  375.                 THEN
  376.             ELSE
  377.                 FALSE -> ok
  378.             THEN
  379.         ELSE
  380.             \ stop! reached the root dir, i.e. 'disk:'
  381.             FALSE -> dirflg
  382.         THEN
  383.         fib dealloc.fib
  384.     ELSE
  385.         FALSE -> ok
  386.     THEN
  387. ;
  388.  
  389.  
  390. : remove.final.slash          ( stradd -- )
  391. \ get rid of final slash or colon on the name if there
  392.     DUP C@
  393.     OVER + C@  ASCII / =  IF
  394.         DUP C@ 1-  SWAP C!
  395.     ELSE
  396.         DROP
  397.     THEN
  398. ;
  399.  
  400.  
  401. : ?dev_name         ( stradd -- )
  402. \ return true if name ends in a colon
  403.     DUP C@
  404.     SWAP + C@  ASCII : =
  405. ;
  406.  
  407.  
  408. : get.full-path     { wbarg | fib pdirflg ok --> ok }
  409. \ full path of file is written into PAD
  410.     PAD init.name
  411.     TRUE -> ok
  412.     alloc.fib  DUP -> fib  IF
  413.         \ get the directory path
  414.         wbarg ..@ wa_Lock  fib    Examine()  DROP
  415.         wbarg ..@ wa_Lock get.parentdir  SWAP -> pdirflg  IF
  416.             \ get directory name
  417.             fib .. fib_FileName  0COUNT  PAD  build.name
  418.             pdirflg IF
  419.                 " /" COUNT  PAD  build.name
  420.             ELSE
  421.                 " :" COUNT  PAD  build.name
  422.             THEN
  423.             \ get name
  424.             wbarg ..@ wa_Name >REL 0COUNT  PAD  build.name
  425.         ELSE
  426.             FALSE -> ok
  427.         THEN
  428.         fib dealloc.fib
  429.         PAD remove.final.slash
  430.         PAD ?dev_name IF
  431.             \ possibly a disk; try...
  432.             " Disk" COUNT PAD build.name
  433.         THEN
  434.     ELSE
  435.         FALSE -> ok
  436.     THEN
  437. ;
  438.  
  439.  
  440.